perm filename 12T.F4[12,LCS]1 blob
sn#089286 filedate 1974-03-03 generic text, type T, neo UTF8
00100 C ********** MATRIX FEB. 16,73 ******** PRINTS 12-TONE CHART ******
00200 C 'S'EARCH WILL LOCATE ROW SOURCES OF CHORDS, ETC.
00300 COMMON INV(12),IR(12),N(12),J(13,13),ISCAL(12),IS2(12),
00400 1 INP2(72),INP(72),NRW
00500 1,IC(6),ISQ(25,25),NAME(10),INOT(49),JA(12)
00600 DATA ISCAL/'C','C#','D','D#','E','F','F#','G','G#',
00700 1 'A','A#','B'/,INV/'I0','I1','I2','I3','I4','I5','I6','I7',
00800 1 'I8','I9','I10','I11'/,IR/'P0','P1','P2','P3','P4',
00900 1 'P5','P6','P7','P8','P9','P10','P11'/
01100 DATA IS2/'C','$','D','$','E','F','$','G','$','A','$','B'/
01110 C N=NEW ROW, T=TYPE MATRIX, L=LPT, S=SEARCH, R=READ FILE 'ROWS', W=WRITE
01200 662 TYPE 61
01300 ACCEPT 1,NRW
01400 IF(NRW.EQ.'L')GO TO 62
01500 IF(NRW.EQ.'T')GO TO 1188
01510 IF(NRW.NE.'R'.AND.NRW.NE.'W')GO TO 6620
01520 CALL RDWRT
01540 C WE'VE JUST READ IN A ROW.
01600 6620 IF(NRW.NE.'S')GO TO 64
01700 663 TYPE 65
01800 GO TO 661
01900 65 FORMAT(' TYPE NOTES'/)
02000 61 FORMAT(/' N=NEW, T=TYPE MTRX, S=SRCH, R=RD, W=WRT, L=LST'/)
02100 300 FORMAT(' PRINT HOW MANY?'/)
02200 200 FORMAT(' TYPE NAME OF WORK'/)
02300 62 KREP=0
02500 TYPE 300
02600 ACCEPT 400,KREP
02700 1188 KREP=KREP-1
02900 JOUT=3
03000 IF(NRW.EQ.'T')JOUT=5
03100 GO TO 288
03200 64 HEX=-10
03400 J(2,1)=INV(1)
03500 J(1,2)=IR(1)
03530 IF(NRW.EQ.'R')GO TO 661
03560 TYPE 200
03600 ACCEPT 444,NAME
03700 188 TYPE 100
03800 661 JOUT=5
04100 FIRST=-1.
04150 IF(NRW.EQ.'R')GO TO 6650
04200 ACCEPT 1,INP2
04400 IF(NRW.EQ.'S')GO TO 498
04500 6650 DO 665 KGZ=1,72
04600 665 INP(KGZ)=INP2(KGZ)
04700 GO TO 198
05000 C IF A 13TH NOTE IS ADDED, THEN NO PRINTOUT.
05100 C TYPE 'S' TO SEARCH, 'SP' OUTPUTS TO LPT.
05300 498 K=0
05400 JS=0
05500 ISQ2=0
06100 298 K=K+1
06200 DID=0
06300 IF(K.GT.72)GO TO 8888
06400 L=INP2(K)
06500 IF(L.EQ.' ')GO TO 298
06600 DO 888 M=1,12
06700 IF(L.NE.IS2(M))GO TO 888
06800 LL=M
06900 K=K+1
07000 IF(INP2(K).EQ.'S')LL=M+1
07100 IF(INP2(K).EQ.'F')LL=M-1
07200 ISQ2=ISQ2+2**LL
07300 C ASSIGNS # TO EACH NOTE
07400 JS=JS+1
07500 C JS IS # OF NOTES IN GROUP TO BE FOUND.
07600 GO TO 298
07700 888 CONTINUE
07800 8888 IF(JS.EQ.0)CALL EXIT
07900 C NO NOTES WERE GIVEN.
08000 IF(FIRST)LGRP=JS
08100 FIRST=0
08200 C SAVE # OF NOTES TO BE FOUND.
08300 JGRP=JS-1
08400 DO 333 NN=1,2
08600 DO 333 K=1,13
08700 C '+JGRP' IS FOR WRAP-AROUND
08800 JQ=2
08900 DO 222 L=1,12
09000 KQ=L
09100 C SETS # OF 1ST NOTE OF FOUND GROUP.
09200 LL=0
09300 DO 223 KK=JQ,JQ+JGRP
09400 NR=KK
09500 NI=K
09600 IF(NN.EQ.1)GO TO 223
09700 NR=K
09800 NI=KK
09900 223 LL=LL+ISQ(NR,NI)
10000 2223 IF(LL.EQ.ISQ2)GO TO 334
10100 222 JQ=JQ+1
10200 GO TO 333
10300 334 NR=1
10400 IF(LGRP.NE.JS)TYPE 67,JS
10500 LGRP=JS
10600 C NN=1, R FORMS. NN=2, I FORMS.
10700 IF(NN.EQ.1)GO TO 2334
10800 NI=1
10900 NR=K
11000 C K WILL BE 1ST NOTE OF GROUP IN ROW.
11100 2334 WRITE(JOUT, 66),J(NR,NI),KQ
11200 DID=-1.
11300 333 CONTINUE
11400 IF(DID)GO TO 3333
11600 IF(JGRP.NE.1)GO TO 3334
11700 C DON'T TRY AGAIN IF GROUP IS DOWN TO 2.
11800 TYPE 67,JGRP
11900 GO TO 3333
12000 3334 DO 398 K=72,1,-1
12100 IF(INP2(K).EQ.' ')GO TO 398
12200 3398 INP2(K)=' '
12300 INP2(K-1)=' '
12400 GO TO 498
12500 398 CONTINUE
12600 C ABOVE SHORTENS GROUP BY ONE.
12700 3333 TYPE 60
12800 GO TO 662
12900 198 JJ=1
13000 K=0
13100 98 K=K+1
13200 IF(K.GT.72)GO TO 9999
13300 L=INP(K)
13400 IF(L.EQ.' ')GO TO 98
13500 IF(JJ.EQ.14)GO TO 99
13600 C ANYTHING TYPED AFTER 12 NOTES CAUSES 'NOPRIN'.
13700 DO 999 M=1,12
13800 IF(L.NE.IS2(M))GO TO 999
13900 LL=M
14000 K=K+1
14100 IF(INP(K).EQ.'S')LL=M+1
14200 IF(INP(K).EQ.'F')LL=M-1
14300 JA(JJ)=LL
14400 C SAVES #S FOR NOTATION
14500 JJ=JJ+1
14600 J(JJ,2)=LL
14700 ISQ(JJ,2)=2**LL
14800 C SETS VALUE AS POWER OF 2 FOR EACH NOTE.
14900 GO TO 98
15000 999 CONTINUE
15200 99 CONTINUE
15300
15400 9999 IF(JJ.EQ.1)CALL EXIT
15500 C NO NOTES WERE GIVEN.
15600 I=J(2,2)
15700 C WORKS OUT MATRIX
15800 DO 9 K=3,13
15900 LL=J(K,2)-I+1
16000 IF(LL.LE.0)LL=LL+12
16100 9 J(K,1)=INV(LL)
16200 DO 2 K=2,12
16300 2 N(K)=J(K+1,2)-I
16400 DO 3 K=3,13
16500 LL=I-N(K-1)
16600 IF(LL.LT.1)LL=LL+12
16700 IF(LL.GT.12)LL=LL-12
16800 ISQ(2,K)=2**LL
16900 J(2,K)=LL
17000 LL=LL+1-I
17100 IF(LL.LE.0)LL=LL+12
17200 3 J(1,K)=IR(LL)
17300 DO 4 K=3,13
17400 DO 4 I=3,13
17500 LL=J(2,I)+N(K-1)
17600 IF(LL.LT.1)LL=LL+12
17700 IF(LL.GT.12)LL=LL-12
17800 ISQ(K,I)=2**LL
17900 4 J(K,I)=ISCAL(LL)
18000 DO 7 K=2,13
18100 7 J(K,2)=ISCAL(J(K,2))
18200 DO 8 K=3,13
18300 8 J(2,K)=ISCAL(J(2,K))
18400 10 J(1,1)=0
18500 DO 28 K=2,13
18600 DO 28 L=2,13
18700 KQ=ISQ(K,L)
18800 ISQ(K+12,L)=KQ
18900 28 ISQ(K,L+12)=KQ
19000 C +12 FOR WRAP-AROUND
19200 288 WRITE(JOUT, 60),NAME
19300 WRITE(JOUT, 60)
19400 C NEXT JUMPS OVER NOTATION PRINT.
19500 GO TO 5557
19600 C UNTIL 210, PRINTS NOTATION
19700 G=' '
19800 WRITE(JOUT, 201),G
19900 L=5
20000 DO 202 IJ=1,7
20100 LN=-1
20200 IF(IJ.EQ.2.OR.IJ.EQ.4.OR.IJ.EQ.6)LN=0
20300 C LINE OR SPACE
20400 JK=2
20500 IF(IJ.EQ.1.OR.IJ.EQ.4)JK=1
20600 DO 203 IQ=1,JK
20700 204 DO 205 K=1,49
20800 205 INOT(K)=' '
20900 DO 206 K=1,12
21000 IF(JA(K).NE.L)GO TO 206
21100 C SKIPS IF NO NOTE NOW
21200 IK=K
21300 L=L-1
21400 IF(L.EQ.0)L=12
21500 M=K*4-1
21600 IF(IK.GT.6)M=M+2
21700 2000 INOT(M)='O'
21800 IF(L.EQ.3.OR.L.EQ.1.OR.L.EQ.10.OR.L.EQ.8.OR.
21900 1 L.EQ.6)INOT(M-1)='#'
22000 IF(L.EQ.2.OR.L.EQ.12.OR.L.EQ.9.OR.L.EQ.7.OR.
22100 1 L.EQ.5)LN=0
22200 GO TO 208
22300 206 CONTINUE
22400 208 IF(LN)WRITE(JOUT, 209),(INOT(IZ),IZ=1,M)
22500 C OVERPRINTS
22600 203 IF(LN.EQ.0)WRITE(JOUT, 210),(INOT(IZ),IZ=1,M)
22700 G=' '
22800 IF(IJ.EQ.5)G='G'
22900 202 IF(IJ.NE.2.AND.IJ.NE.4.AND.IJ.NE.6)WRITE(JOUT, 201),G
23000 201 FORMAT(2XA1,52('-'))
23100 209 FORMAT(4X49A1)
23200 210 FORMAT('+',4X49A1)
23300 C PRINTS LINES FOR SCRATCH.
23400
23500 5557 WRITE(JOUT, 60)
23600 J(1,1)=' '
23700 WRITE(JOUT, 5),J
23900 CC IF(JOUT.EQ.5)PAUSE
24000 111 CONTINUE
24100 DO 1111 K=1,6
24200 1111 IC(K)=0
24300 LR=1
24400 JGRP=6
24500 KGRP=2
24600 MPRINT=2
24700 DO 1000 IGRP=1,4
24800 KK=0
24900 DO 17 K=1,12,JGRP
25000 JJ=0
25100 DO 117 L=1,JGRP
25200 117 JJ=JJ+ISQ(K+L,2)
25300 KK=KK+1
25400 17 IC(KK)=JJ
25500 MM=0
25600 MCNT=0
25700 DO 19 NN=1,2
25800 JQQ=4-NN
25900 DO 19 I=JQQ,13
26000 DO 21 KK=1,KGRP
26100 DO 18 K=1,12,JGRP
26200 JJ=0
26300 DO 118 L=1,JGRP
26400 NI=I
26500 NR=L+K
26600 IF(NN.EQ.1)GO TO 118
26700 NI=NR
26800 NR=I
26900 118 JJ=ISQ(NR,NI)+JJ
27000 LL=I
27100 GO TO 18
27200 WRITE(JOUT, 400),KK,JGRP,JJ,IGRP,KGRP,K
27300 18 IF(IC(KK).EQ.JJ)GO TO 21
27400 GO TO 19
27500 21 CONTINUE
27600 LI=LL
27700 LR=1
27800 IF(NN.EQ.1)GO TO 221
27900 LI=1
28000 LR=LL
28200 221 IF(MM)GO TO 55
28300 MPRINT=MPRINT+1
28400 C COUNTS FOR STAFF PRINTOUT
28500 GO TO (11,22,33,44),IGRP
28600 11 WRITE(JOUT, 51)
28700 HEX=0
28800 GO TO 55
28900 22 WRITE(JOUT, 52)
29000 HEX=-10
29100 GO TO 55
29200 33 WRITE(JOUT, 53)
29300 HEX=-10
29400 GO TO 55
29500 44 WRITE(JOUT, 54)
29600 HEX=-10
29700 55 MM=-1
29900 IF(HEX.EQ.5)WRITE(JOUT, 51)
30000 HEX=HEX+1
30100 MCNT=MCNT+1
30200 WRITE(JOUT, 50),J(LR,LI)
30300 IF(MCNT.LT.7)GO TO 19
30400 MCNT=0
30500 MM=0
30600 C TO STAY IN 8 1/2" WIDTH ON PAPER
30700 19 CONTINUE
30800 JGRP=JGRP-1
30900 IF(IGRP.EQ.1)JGRP=4
31000 1000 KGRP=12/JGRP
31100 KREP=KREP-1
31300 IF(JOUT.EQ.5)GO TO 662
31400 WRITE(JOUT, 60)
31500 L=5-MPRINT/2
31600 DO 5555 K=1,L
31700 5555 WRITE(JOUT, 5556)
31800 IF(KREP)CALL EXIT
31900 WRITE(JOUT, 500)
32000 GO TO 10
32100 5556 FORMAT(/5(1X,80('-')/)/)
32200 51 FORMAT(/' HEXADS ....P0',$)
32300 52 FORMAT(/' TETRADS ...P0',$)
32400 53 FORMAT(/' TRIADS ....P0',$)
32500 54 FORMAT(/' DYADS .....P0',$)
32600 5 FORMAT(1XA4,2(1X6A4)/2(/6(1XA4,2(1X6A4)/)))
32700 1 FORMAT (72A1)
32800 444 FORMAT (10A5)
32900 50 FORMAT('+ = ',A3,$)
33000 60 FORMAT(1X10A5)
33100 66 FORMAT(1XA5,I2,3XI2)
33200 67 FORMAT(' GROUP SHORTENED TO ',I2)
33300 100 FORMAT(' TYPE 12 NOTES'/)
33400 500 FORMAT('1')
33500 400 FORMAT(6I)
33600 END